home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / C / MEMORY.C < prev    next >
Encoding:
C/C++ Source or Header  |  1993-11-09  |  12.7 KB  |  460 lines
  1. /* MEMORY.C
  2.  ************************************************************************
  3.  *                                    *
  4.  *        PC Scheme/Geneva 4.00 Borland C code            *
  5.  *                                    *
  6.  * (c) 1985-1988 by Texas Instruments, Inc. See COPYRIGHT.TXT        *
  7.  * (c) 1992 by L. Bartholdi & M. Vuilleumier, University of Geneva    *
  8.  *                                    *
  9.  *----------------------------------------------------------------------*
  10.  *                                    *
  11.  *        Allocate Space in a Scheme Page                *
  12.  *                                    *
  13.  *----------------------------------------------------------------------*
  14.  *                                    *
  15.  * Created by: John Jensen        Date: 1985            *
  16.  * Revision history:                            *
  17.  * - 18 Jun 92:    Renaissance (Borland Compilers, ...)            *
  18.  * - 20 Jan 93: REG class created for automatic gc management (mv)    *
  19.  *                                    *
  20.  *                    ``In nomine omnipotentii dei''    *
  21.  ************************************************************************/
  22.  
  23. #include    <string.h>
  24. #include    <stdlib.h>
  25. #include    <conio.h>
  26. #include     "scheme.h"
  27.  
  28. /************************************************************************/
  29. /* Allocate a Page in Scheme's Memory                    */
  30. /************************************************************************/
  31. unsigned    alloc_page(unsigned type, unsigned minsize)
  32. {
  33.     int             newpage, previous = END_LIST;
  34.  
  35.     for( newpage = freepage; newpage != END_LIST; previous = newpage, newpage = pagelink[newpage] )
  36.     if( psize[newpage] >= minsize )
  37.     {
  38.         if( previous == END_LIST )
  39.             freepage = pagelink[newpage];
  40.         else    pagelink[previous] = pagelink[newpage];
  41.         break;
  42.     }
  43.     if( newpage == END_LIST )    /* failure: no page big enough */
  44.         return    END_LIST;
  45.  
  46.     /* Define page management characteristics for this type page */
  47.     attrib[newpage] = pageattr[type/2];
  48.     pagelink[newpage] = pagelist[type/2];
  49.     ptype[newpage] = type;
  50.     pagelist[type/2] = newpage;
  51.  
  52.     zero_page(newpage);
  53.  
  54.     /* Initialize free storage chains for appropriate data type */
  55.     switch (type)
  56.     {
  57.     case LISTTYPE:
  58.     case FLOTYPE:
  59.         swpage(newpage);
  60.         break;
  61.  
  62.     case BIGTYPE:
  63.     case SYMTYPE:
  64.     case STRTYPE:
  65.     case I86TYPE:
  66.     case VECTTYPE:
  67.     case CLOSTYPE:
  68.     case CONTTYPE:
  69.     case CODETYPE:
  70.     case FREETYPE:
  71.     case PORTTYPE:
  72.     case ENVTYPE:
  73.         put_ptr( newpage, 0, FREETYPE, psize[newpage] );
  74.         nextcell[newpage] = 0;
  75.         break;
  76. #ifdef    VMDEBUG
  77.     default:
  78.         zprintf("[VM INTERNAL ERROR] alloc_page: Invalid type: %d\n", type);
  79. #endif
  80.     }
  81.  
  82.     /* re-define page attributes and type (GC thinks this is a free page) */
  83.     attrib[newpage] = pageattr[type/2];
  84.     ptype[newpage] = type;
  85.  
  86.     return    newpage;
  87. }
  88.  
  89. #define    ALLOCMETHODS    3
  90. void    (*allocstub[ALLOCMETHODS])() = { garbage, gcsquish, out_of_memory };
  91.  
  92. /************************************************************************/
  93. /* Allocate a List Cell                            */
  94. /*                                    */
  95. /* Note:  this routine will always return a list cell unless        */
  96. /* memory is exhausted, in which case Scheme terminates            */
  97. /* abnormally                                */
  98. /************************************************************************/
  99. int    find_list_cell(REGPTR reg)
  100. {
  101.     while( (reg->disp = nextcell[listpage]) == END_LIST )
  102.     if( (listpage = pagelink[listpage]) == END_LIST )
  103.     if ((listpage = alloc_page(LISTTYPE, 0)) == END_LIST)
  104.     {
  105.         listpage = 0;        /* just point to page 0 - null list */
  106.         return    0;        /* failed */
  107.     }
  108.  
  109.     reg->page = ADJPAGE(listpage);
  110.     nextcell[listpage] = scheme2c(listpage,reg->disp)->list.free.next;
  111.  
  112.     return    1;
  113. }
  114.  
  115. void    alloc_list_cell(REGPTR reg)
  116. {
  117.     for( int i = 0; i < ALLOCMETHODS; i++ )
  118.     {
  119.         if( find_list_cell(reg) )
  120.             return;
  121.         reg->page = ADJPAGE(NIL_PAGE);    /* legitimize pointer before GC */
  122.         allocstub[i]();
  123.     }
  124. }
  125.  
  126. /************************************************************************/
  127. /* Allocate a Flonum                            */
  128. /* Note:  this routine will always return a flonum cell unless        */
  129. /* memory is exhausted, in which case Scheme terminates            */
  130. /* abnormally                                */
  131. /************************************************************************/
  132. int    find_flonum(REGPTR reg)
  133. {
  134.     FLONUM    far    *f;
  135.  
  136.     if( flopage == END_LIST )
  137.     if( (flopage = alloc_page(FLOTYPE, 0)) == END_LIST )
  138.         return    0;
  139.  
  140.     while( (reg->disp = nextcell[flopage]) == END_LIST )
  141.     if( (flopage = pagelink[flopage]) == END_LIST )
  142.     if( (flopage = alloc_page(FLOTYPE, 0)) == END_LIST )
  143.         return    0;    /* failed */
  144.  
  145.     reg->page = ADJPAGE(flopage);
  146.     f = ®2c(reg)->flonum;
  147.  
  148.     nextcell[flopage] = f->next;
  149.     f->type = FLOTYPE;
  150.  
  151.     return    1;
  152. }
  153.  
  154. void    alloc_flonum( REGPTR reg, double value )
  155. {
  156.     if (value == 0.0 || value == 1.0 || value == -1.0)
  157.     {
  158.         reg->page = ADJPAGE(SPECFLO);
  159.         reg->disp = sizeof(FLONUM) * (value + 1);
  160.         return;
  161.     }
  162.     for( int i = 0; i < ALLOCMETHODS; i++ )
  163.     {
  164.         if( find_flonum(reg) )
  165.         {
  166.             reg2c(reg)->flonum.data = value;
  167.             return;
  168.         }
  169.         reg->page = ADJPAGE(NIL_PAGE);    /* legitimize pointer before GC */
  170.         allocstub[i]();
  171.     }
  172. }
  173.  
  174. /************************************************************************/
  175. /* Allocate String Constant                        */
  176. /************************************************************************/
  177. void    alloc_string(REGPTR reg, char *string)
  178. {
  179.     alloc_block( reg, STRTYPE, strlen(string) );
  180.     put_str( string, CORRPAGE(reg->page), reg->disp );
  181. }
  182.  
  183. /**************************************************************************/
  184. /* Find a big block in Scheme's memory                                                  */
  185. /**************************************************************************/
  186. unsigned find_big_block(unsigned size)
  187. {
  188.     unsigned    lastpage = NUMPAGES - emspages, page;
  189.  
  190.     char        isfree[NUMPAGES];
  191.  
  192.     /* Initialize isfree table */
  193.     for( page = 0; page < NUMPAGES; page++ )
  194.         isfree[page] = 0;
  195.  
  196.     /* Record the number of all free pages */
  197.     for( page = freepage; page != END_LIST; page = pagelink[page] )
  198.         isfree[page] = 1;
  199.  
  200.     for( page = DEDPAGES; page < lastpage; page++ )
  201.     if( isfree[page] )    /* candidate */
  202.     {
  203.         unsigned    cursize = 0;
  204.  
  205.         for( int i = page; i < lastpage && isfree[i]; i++ )
  206.         if( (cursize += psize[i]) >= size )    /* that's enough */
  207.         {
  208.             isfree[page] = 0;
  209.             psize[page] = cursize;
  210.             while( i > page )    /* we lose these pages */
  211.             {
  212.                 psize[i] = 0;
  213.                 attrib[i].FLAGS.nomemory = 1;
  214.                 isfree[i--] = 0;
  215.             }
  216.  
  217.             for( freepage = END_LIST, i = lastpage-1; i >= DEDPAGES; i-- )
  218.             if( isfree[i] )
  219.                 pagelink[i] = freepage, freepage = i;
  220.  
  221.             return    page;
  222.         }
  223.     }
  224.     return    0xffff;        /* no pages found */
  225. }
  226.  
  227. /************************************************************************/
  228. /* Allocate a Large Block in Scheme's Memory                            */
  229. /************************************************************************/
  230. void    alloc_big_block(REGPTR reg, unsigned type, unsigned size)
  231. {
  232.     unsigned    page;
  233.  
  234.     for( int i = 0; i < ALLOCMETHODS; i++ )
  235.     if( (page = find_big_block(size)) == 0xffff )
  236.         allocstub[i]();
  237.     else    break;
  238.  
  239.     zero_page(page);
  240.     put_ptr( page, 0, type/2, size );
  241.     nextcell[page] = END_LIST;
  242.     if( size <= psize[page] - BLK_OVHD )
  243.     {
  244.         put_ptr( page, size, FREETYPE, psize[page] - size );
  245.         nextcell[page] = size;
  246.     }
  247.     ptype[page] = type;
  248.     attrib[page] = pageattr[type/2];
  249.     pagelink[page] = pagelist[type/2];
  250.     pagelist[type/2] = page;
  251.  
  252.     reg->page = ADJPAGE(page);
  253.     reg->disp = 0;
  254. }
  255.  
  256. /************************************************************************/
  257. /* Register class definitions                        */
  258. /************************************************************************/
  259. REG    *REG::first = NULL;
  260.  
  261. void    REG::mark(void)                /* mark all registers */
  262. {
  263.     REG    *current = first;
  264.  
  265.     while( current ) {
  266.         gcmark( current->page, current->disp );
  267.         current = current->next;
  268.     }
  269. }
  270.  
  271. void    REG::relocate(void)            /* relocate all registers */
  272. {
  273.     REG    *current = first;
  274.  
  275.     while( current ) {
  276.         rel_reg( current );
  277.         current = current->next;
  278.     }
  279. }
  280.  
  281. int    REG::check(void)            /* check consistency */
  282. {
  283.     REG    *current = first;
  284.  
  285.     while( current ) {
  286.         register pg = current->page;
  287.  
  288.         if( pg & 1 )    
  289.             return 1;
  290.         else
  291.             pg = CORRPAGE(pg);
  292.  
  293.         if( pg != SPECFIX && pg != SPECCHAR && 
  294.             ( pg >= nextpage || current->disp >= psize[pg] ) )
  295.             return 1;
  296.  
  297.         current = current->next;
  298.     }
  299.     return 0;
  300. }
  301.  
  302. void    REG::cleanup(REG *low, REG *high)    /* selective destructor */
  303. {
  304.     REG    *current = first;
  305.     
  306.     do {                    // last allocated object ?
  307.         if( low <= current && current < high )
  308.             first = current->next;
  309.     } while( first == (current = current->next) );
  310.  
  311.     current = first;
  312.         
  313.     while( current->next ) {
  314.         if( low <= current->next && current->next < high )
  315.             current->next = current->next->next;
  316.  
  317.         current = current->next;
  318.     }
  319. }
  320.  
  321. REG::~REG(void)                    /* the destructor */
  322. {
  323.     if( first == this )                // last allocated object ?
  324.         first = next;
  325.     else {
  326.         REG    *current = first;
  327.  
  328.         while( current ) {
  329.             if( current->next == this ) {
  330.                 current->next = next;
  331.                 break;        
  332.             }
  333.             current = current->next;
  334.         }
  335.     }
  336. }
  337.  
  338. /************************************************************************/
  339. /* Scheme static registers                        */
  340. /************************************************************************/
  341.  
  342. REG     nil_reg    ( NIL_DISP, NIL_PAGE*2 ); // nil register reference
  343. REG     fnv_reg    ( NIL_DISP, NIL_PAGE*2 ); // Fluid Environment Pointer
  344. REG     gnv_reg    ( 0, ENV_PAGE*2 )    ; // Global Environment Pointer
  345. REG    fnv_save ( NIL_DISP, NIL_PAGE*2 );// fluid enviornment pointer save area
  346. REG    stl_save ( NIL_DISP, NIL_PAGE*2 );// scheme-top-level value save area
  347. REG     cb_reg    ( 0, SPECCODE*2 )    ; // Code Base Pointer
  348. REG    prev_reg ( NIL_DISP, NIL_PAGE*2 );// pointer to previous stack segment
  349. REG     tmp_reg    ( NIL_DISP, NIL_PAGE*2 );
  350. REG     tm2_reg    ( NIL_DISP, NIL_PAGE*2 );
  351. REG     trns_reg    ( NIL_DISP, NIL_PAGE*2 ); // Transcript File pointer
  352. REG     port_reg    ( NIL_DISP, NIL_PAGE*2 );
  353. REG     console_reg    ( NIL_DISP, NIL_PAGE*2 );
  354. REG     macro_reg    ( NIL_DISP, NIL_PAGE*2 ); // Macro key continuation pointer
  355. REG    quote_reg    ( NIL_DISP, NIL_PAGE*2 ); //Storage for interned symbol 'quote
  356.  
  357. /************************************************************************/
  358. /* Invoke garbage collection                        */
  359. /************************************************************************/
  360. int    compact_every = 7;
  361. int    gc_count = 0;
  362. void    garbage(void)
  363. {
  364.     gc_on(0);        /* display "Garbage Collecting" message */
  365.     gc_count++;
  366.     mark();
  367.     gc_oht();        /* clean up the object hash table */
  368.     gcsweep();
  369.     if (listpage == END_LIST)
  370.         listpage = 0;
  371.     gc_off();        /* un-display "garbage collection" message */
  372.  
  373.     if (!(gc_count % compact_every))
  374.         gcsquish();
  375. }
  376.  
  377. /* mark everything pointed to for the garbage collector */
  378. void    mark(void)
  379. {
  380.     unsigned             i;
  381.  
  382.     /* mark all objects pointed to by the Scheme VM's registers */
  383.     for (i = 0; i < NUM_REGS; i++ )
  384.         gcmark(regs[i].page, regs[i].disp);
  385.  
  386.     /* mark all objects pointed by active registers */
  387.     REG::mark();
  388.  
  389.     /* preserve everything pointed to by active stack entries */
  390.     for (i = 0; i <= topofstack / sizeof(POINTER); i++)
  391.         gcmark(s_stack[i].page, s_stack[i].disp);
  392.  
  393.     /* preserve everything pointed to by the oblist */
  394.     for (i = 0; i < HT_SIZE; i++)
  395.     if (hash_page[i])
  396.         gcmark(hash_page[i], hash_disp[i]);
  397.  
  398.     /* preserve everything pointed to by the property list */
  399.     for (i = 0; i < HT_SIZE; i++)
  400.     if (prop_page[i])
  401.         gcmark(prop_page[i], prop_disp[i]);
  402. }
  403.  
  404. /************************************************************************/
  405. /* Memory Exhausted-- Attempt to Perform SCHEME-RESET            */
  406. /************************************************************************/
  407. void    out_of_memory(void)
  408. {
  409.     int             i;
  410.  
  411.     if( nextpage < lastpage && nextpage < NUMPAGES )
  412.     {
  413.         freepage = nextpage;
  414.         for( i = 0; i < 8 && nextpage < (NUMPAGES - 1); i++ )
  415.         {
  416.             pagelink[nextpage] = nextpage + 1;
  417.             attrib[nextpage++].FLAGS.nomemory = 1;
  418.         }
  419.         pagelink[nextpage - 1] = END_LIST;
  420.     } else {
  421.         zprintf("\n[VM ERROR encountered!] Out of memory, attempting to execute SCHEME-RESET\n"
  422.                "[Returning to top level]\n");
  423.         force_reset();
  424.     }
  425. }
  426.  
  427. /************************************************************************/
  428. /* Print Message and Exit Scheme                    */
  429. /************************************************************************/
  430. void    print_and_exit( char *msg )
  431. {
  432.     zprintf( msg );
  433.     GETCH();
  434.     exit( 0xff );
  435. }
  436.  
  437. /************************************************************************/
  438. /* TIPC Scheme '84 Free Space                        */
  439. /*                                    */
  440. /* Purpose:  This Routine will return the number of bytes of free    */
  441. /* user memory.                                */
  442. /************************************************************************/
  443. unsigned long    freesp(void)
  444. {
  445.     unsigned    space[NUMPAGES];    /* Free memory per page array */
  446.     int             i;
  447.     unsigned long   bytes_free;        /* word to sum bytes available */
  448.  
  449.     sum_space(space);
  450.     bytes_free = 0;
  451.  
  452.     for (i = DEDPAGES; i < lastpage; i++)
  453.         if (ptype[i] == FREETYPE)
  454.             bytes_free += psize[i];
  455.         else              
  456.             bytes_free += space[i];
  457.  
  458.     return (bytes_free);
  459. }
  460.